home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
BMUG Revelations
/
BMUG Revelations.toast
/
Programming
/
Programming Languages
/
UCB Logo 3.0
/
CSLS
/
algs
next >
Wrap
Text File
|
1992-09-04
|
7KB
|
270 lines
TO ACOUNT :ARRAY
OUTPUT COUNT :ARRAY
END
TO ADDCHILD :TREE :CHILD
MAKE :TREE LPUT :CHILD THING :TREE
END
TO ADECK
LOCAL [RANKS SUITS]
MAKE "RANKS LISTTOARRAY [A 2 3 4 5 6 7 8 9 10 J Q K]
MAKE "SUITS LISTTOARRAY [H S D C]
MAKE "DECK ARRAY 52
MAKE "INDEX 0
FOR [J 0 3] ~
[FOR [I 0 12] ~
[PARRAY :DECK :INDEX WORD (GARRAY :RANKS :I) (GARRAY :SUITS :J) ~
MAKE "INDEX :INDEX+1]]
END
TO AEQUALP :ARRAY1 :ARRAY2
OP EQUALP :ARRAY1 :ARRAY2
END
TO GARRAY :ARRAY :INDEX
OP ITEM :INDEX+1 :ARRAY
END
TO PARRAY :ARRAY :INDEX :VALUE
SETITEM :INDEX+1 :ARRAY :VALUE
END
TO AREACODE :PAIR
OUTPUT FIRST :PAIR
END
TO ASHUFFLE
ADECK
FOR [I 51 1] [ASHUFFLE1 :I (RANDOM :I+1) (GARRAY :DECK :I)]
END
TO ASHUFFLE1 :I :J :OLDI
PARRAY :DECK :I (GARRAY :DECK :J)
PARRAY :DECK :J :OLDI
END
TO BALANCE :LIST
IF EMPTYP :LIST [OUTPUT []]
IF EMPTYP BF :LIST [OUTPUT LEAF FIRST :LIST]
OUTPUT BALANCE1 (INT (COUNT :LIST)/2) :LIST []
END
TO BALANCE1 :COUNT :IN :OUT
IF EQUALP :COUNT 0 ~
[OUTPUT TREE (FIRST :IN) (LIST BALANCE REVERSE :OUT BALANCE BF :IN)]
OUTPUT BALANCE1 (:COUNT-1) (BF :IN) (FPUT FIRST :IN :OUT)
END
TO CHILDREN :NODE
OUTPUT BUTFIRST THING :NODE
END
TO CITIES :NAME
OUTPUT CITIES1 FINDDATUM :NAME :WORLD
END
TO CITIES1 :SUBTREE
IF LEAFP :SUBTREE [OUTPUT (LIST DATUM :SUBTREE)]
OUTPUT MAP.SE [CITIES1 ?] CHILDREN :SUBTREE
END
TO CITY :PAIR
OUTPUT BUTFIRST :PAIR
END
TO DATUM :NODE
OUTPUT FIRST THING :NODE
END
TO FINDDATUM :NAME :TREE
IF EQUALP :NAME DATUM :TREE [OUTPUT :TREE]
OUTPUT TRANSFER [NOT EMPTYP ?OUT] [FINDDATUM :NAME ?IN] CHILDREN :TREE
END
TO HIGHBRANCH :TREE
IF LEAFP :TREE [OUTPUT []]
OUTPUT LAST CHILDREN :TREE
END
TO HOWMANY
PRINT :COMPARISONS
ERN "COMPARISONS
END
TO LDECK
OUTPUT CROSSMAP [WORD :1 :2] [[A 2 3 4 5 6 7 8 9 10 J Q K] [H S D C]]
END
TO LEAF :DATUM
OUTPUT TREE :DATUM []
END
TO LEAFP :NODE
OUTPUT EMPTYP CHILDREN :NODE
END
TO LEAVES :LEAVES
OUTPUT MAP [LEAF ?] :LEAVES
END
TO LESSTHANP :A :B
IF NOT NAMEP "COMPARISONS [MAKE "COMPARISONS 0]
MAKE "COMPARISONS :COMPARISONS+1
OUTPUT :A < :B
END
TO LISTCITY :CODE
OUTPUT CITY FIND [EQUALP :CODE AREACODE ?] :CODELIST
END
TO LOCATE :CITY
OUTPUT LOCATE1 :CITY :WORLD
END
TO LOCATE1 :CITY :SUBTREE
LOCAL "RESULT
IF LEAFP :SUBTREE [OUTPUT IFELSE EQUALP :CITY DATUM :SUBTREE [(LIST :CITY)] [[]]]
MAKE "RESULT TRANSFER [NOT EMPTYP ?OUT] [LOCATE1 :CITY ?IN] CHILDREN :SUBTREE
IF EMPTYP :RESULT [OUTPUT []]
OUTPUT FPUT (DATUM :SUBTREE) :RESULT
END
TO LOWBRANCH :TREE
IF LEAFP :TREE [OUTPUT []]
OUTPUT FIRST CHILDREN :TREE
END
TO LSHUFFLE :DECK
IF EMPTYP :DECK [OUTPUT []]
LOCAL "INDEX
MAKE "INDEX 1+RANDOM COUNT :DECK
OUTPUT FPUT (ITEM :INDEX :DECK) (LSHUFFLE (REMOVEITEM :INDEX :DECK))
END
TO NEXTROW :COMBS
IF EMPTYP BF :COMBS [OUTPUT :COMBS]
OUTPUT FPUT (SUM FIRST :COMBS FIRST BF :COMBS) NEXTROW BF :COMBS
END
TO PSORT :LIST
LOCAL "SPLIT
IF (COUNT :LIST) < 2 [OUTPUT :LIST]
MAKE "SPLIT (SUM FIRST :LIST LAST :LIST)/2
IF LESSTHANP FIRST :LIST :SPLIT ~
[OUTPUT PSORT1 :SPLIT (BF :LIST) (LIST FIRST :LIST) []]
OUTPUT PSORT1 :SPLIT (BL :LIST) (LIST LAST :LIST) []
END
TO PSORT1 :SPLIT :IN :LOW :HIGH
IF EMPTYP :IN [OUTPUT SE PSORT :LOW PSORT :HIGH]
IF LESSTHANP FIRST :IN :SPLIT ~
[OUTPUT PSORT1 :SPLIT (BF :IN) (FPUT FIRST :IN :LOW) :HIGH]
OUTPUT PSORT1 :SPLIT (BF :IN) :LOW (FPUT FIRST :IN :HIGH)
END
TO QUADRATIC :A :B :C
LOCAL [ROOT X1 X2]
MAKE "ROOT SQRT (:B * :B-4 * :A * :C)
MAKE "X1 (-:B+:ROOT)/(2 * :A)
MAKE "X2 (-:B-:ROOT)/(2 * :A)
PRINT (SE [THE SOLUTIONS ARE] :X1 "AND :X2)
END
TO REALT :N :K
IF EQUALP :K 0 [OUTPUT 1]
IF EQUALP :N 0 [OUTPUT 0]
OUTPUT (T :N :K-1) + (T :N-1 :K)
END
TO REMOVEITEM :NUMBER :LIST
IF EQUALP :NUMBER 1 [OUTPUT BF :LIST]
OUTPUT FPUT (FIRST :LIST) (REMOVEITEM :NUMBER-1 BF :LIST)
END
TO SIMPLEX :BUTTONS
OUTPUT 2 * FIRST CASCADE.2 :BUTTONS ~
[FPUT (SUMPRODS BF ?2 ?1) ?1] [1] ~
[FPUT 1 NEXTROW ?2] [1 1]
END
TO SSORT :LIST
IF (COUNT :LIST) < 2 [OUTPUT :LIST]
OUTPUT SSORT1 (FIRST :LIST) (BF :LIST) []
END
TO SSORT1 :MIN :IN :OUT
IF EMPTYP :IN [OUTPUT FPUT :MIN SSORT :OUT]
IF LESSTHANP :MIN (FIRST :IN) [OP SSORT1 :MIN (BF :IN) (FPUT FIRST :IN :OUT)]
OUTPUT SSORT1 (FIRST :IN) (BF :IN) (FPUT :MIN :OUT)
END
TO SUMPRODS :A :B
IF EMPTYP :A [OUTPUT 0]
OUTPUT SUM (PRODUCT FIRST :A FIRST :B) (SUMPRODS BF :A BF :B)
END
TO T :N :K
LOCAL "RESULT
MAKE "RESULT GPROP (WORD "N :N) (WORD "K :K)
IF NOT EMPTYP :RESULT [OUTPUT :RESULT]
MAKE "RESULT REALT :N :K
PPROP (WORD "N :N) (WORD "K :K) :RESULT
OUTPUT :RESULT
END
TO TREE :DATUM :CHILDREN
LOCAL "NODE
MAKE "NODE GENSYM
MAKE :NODE FPUT :DATUM :CHILDREN
OUTPUT :NODE
END
TO TREECITY :CODE
OUTPUT CITY TREECITY1 :CODE :CODETREE
END
TO TREECITY1 :CODE :TREE
LOCAL "DATUM
IF EMPTYP :TREE [OUTPUT [0 NO CITY]]
MAKE "DATUM DATUM :TREE
IF :CODE = AREACODE :DATUM [OUTPUT :DATUM]
IF :CODE < AREACODE :DATUM [OUTPUT TREECITY1 :CODE LOWBRANCH :TREE]
OUTPUT TREECITY1 :CODE HIGHBRANCH :TREE
END
TO WORLDTREE
MAKE "WORLD TREE "WORLD ~
(LIST (TREE "FRANCE LEAVES [PARIS DIJON AVIGNON]) ~
(TREE "CHINA LEAVES [BEIJING NANKING SHANGHAI CANTON]) ~
(TREE [UNITED STATES] ~
(LIST (TREE [NEW YORK] ~
LEAVES [[NEW YORK] ALBANY ~
ROCHESTER ARMONK]) ~
(TREE "MASSACHUSETTS ~
LEAVES [BOSTON CAMBRIDGE ~
SUDBURY MAYNARD]) ~
(TREE "CALIFORNIA ~
LEAVES [[SAN FRANCISCO] BERKELEY ~
[PALO ALTO] PASADENA]) ~
(TREE "WASHINGTON ~
LEAVES [SEATTLE OLYMPIA]))) ~
(TREE "CANADA ~
(LIST (TREE "ONTARIO ~
LEAVES [TORONTO OTTAWA WINDSOR]) ~
(TREE "QUEBEC ~
LEAVES [MONTREAL QUEBEC LACHINE]) ~
(TREE "MANITOBA LEAVES [WINNIPEG]))))
END
MAKE "CODELIST [[202 WASHINGTON] [206 SEATTLE] [212 NEW YORK] [213 LOS ANGELES] ~
[215 PHILADELPHIA] [303 DENVER] [305 MIAMI] [313 DETROIT] ~
[314 ST. LOUIS] [401 PROVIDENCE] [404 ATLANTA] [408 SUNNYVALE] ~
[414 MILWAUKEE] [415 SAN FRANCISCO] [504 NEW ORLEANS] ~
[608 MADISON] [612 ST. PAUL] [613 KINGSTON] [614 COLUMBUS] ~
[615 NASHVILLE] [617 BOSTON] [702 LAS VEGAS] [704 CHARLOTTE] ~
[712 SIOUX CITY] [714 ANAHEIM] [716 ROCHESTER] [717 SCRANTON] ~
[801 SALT LAKE CITY] [804 NEWPORT NEWS] [805 VENTURA] ~
[808 HONOLULU]]